home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 005 / soundex.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1986-01-09  |  4.9 KB  |  281 lines
  1. 10  PRINT
  2. 20  PRINT "MARTY'S PHONE DIRECTORY"
  3. 30  PRINT
  4. 40  CLEAR 5000
  5. 50  INPUT "How many name cards are needed ";MN
  6. 60  IF MN<1 THEN 50
  7. 70  INPUT "How many Soundex folders are needed ";MC
  8. 80  IF MC<1 THEN 70
  9. 90  YES=1
  10. 100  NO=0
  11. 110  NU$="" : REM No spaces between quotes
  12. 120  S$="01230120022455012623010202"
  13. 130  DIM CO$(MC), NR%(MC), CL%(MC), NA$(MN), NL%(MN), NF$(MN), PH$(MN)
  14. 140  PRINT
  15. 150  PRINT "Setting up the directory file. Hang loose..."
  16. 160  FOR AC=1 TO MC-1
  17. 170  CL%(AC)=AC+1
  18. 180  NEXT AC
  19. 190  CL%(MC)=0
  20. 200  AC=1
  21. 210  FOR AN=1 TO MN-1
  22. 220  NL%(AN)=AN+1
  23. 230  NEXT AN
  24. 240  NL%(MN)=0
  25. 250  AN=1
  26. 260  KN=0
  27. 270  KC=0
  28. 280  SL=0
  29. 290  PRINT
  30. 300  PRINT "Directory contains ";KN;" names"
  31. 310  PRINT "IN ";KC;" Soundex folders."
  32. 320  PRINT "There are ";MN-KN;" unused name cards"
  33. 330  PRINT "and ";MC-KC;" unused Soundex folders."
  34. 340  PRINT
  35. 350  PRINT "1-Find similar names"
  36. 360  PRINT "2-Add names"
  37. 370  PRINT "3-Delete names"
  38. 380  PRINT "4-List entire directory by Soundex codes"
  39. 390  PRINT "5-Save names to disk"
  40. 392  PRINT "6-Load names from disk"
  41. 394  PRINT "7-END"
  42. 400  PRINT
  43. 410  INPUT "Select 1-7";SE
  44. 420  IF SE=7 THEN END
  45. 430  IF SE<1 OR SE>6 THEN 350
  46. 440  ON SE GOSUB 460,650,910,1100,2240,2430
  47. 450  GOTO 290
  48. 460  PRINT
  49. 470  PRINT "Find similar names"
  50. 480  PRINT "Enter last name (empty line for menu)"
  51. 490  N$=NU$
  52. 500  INPUT N$
  53. 510  IF N$=NU$ THEN RETURN
  54. 520  GOSUB 1250
  55. 530  GOSUB 1490
  56. 540  IF OK=YES THEN 570
  57. 550  PRINT "There is no Soundex folder for that name."
  58. 560  GOTO 480
  59. 570  PRINT "Under code ";C$;" are the following names:"
  60. 580  CN=NR%(CC)
  61. 590  IF CN=0 THEN 630
  62. 600  PRINT NA$(CN),NF$(CN),PH$(CN)
  63. 610  CN=NL%(CN)
  64. 620  GOTO 590
  65. 630  PRINT "End of list"
  66. 640  GOTO 480
  67. 650  PRINT
  68. 660  PRINT "Add names"
  69. 670  PRINT "Enter last name, first name, phone"
  70. 680  PRINT "(type an empty line for menu)"
  71. 690  N$=NU$:NF$=NU$:PH$=NU$
  72. 700  INPUT N$,NF$,PH$
  73. 710  IF N$=NU$ THEN RETURN
  74. 720  GOSUB 1250
  75. 730  GOSUB 1490
  76. 740  IF OK=YES THEN 810
  77. 750  IF AN>0 THEN 770
  78. 760  GOTO 890
  79. 770  GOSUB 1600
  80. 780  IF OK=YES THEN 810
  81. 790  PRINT "No more Soundex folders left."
  82. 800  RETURN
  83. 810  GOSUB 1760
  84. 820  IF OK=YES THEN 870
  85. 830  GOSUB 1870
  86. 840  IF OK=NO THEN 890
  87. 850  PRINT "Name added. Enter next name:"
  88. 860  GOTO 680
  89. 870  PRINT "Name already exists. Enter next name:"
  90. 880  GOTO 680
  91. 890  PRINT "No more name cards left."
  92. 900  RETURN
  93. 910  PRINT
  94. 920  PRINT "Delete a name"
  95. 930  PRINT "Enter last name, first name"
  96. 940  PRINT "(type an empty line for menu)"
  97. 950  N$=NU$
  98. 960  INPUT N$ ,NF$
  99. 970  IF N$=NU$ THEN RETURN
  100. 980  GOSUB 1250
  101. 990  GOSUB 1490
  102. 1000  IF OK=YES THEN 1030
  103. 1010  PRINT "No names like that on file."
  104. 1020  RETURN
  105. 1030  GOSUB 1760
  106. 1040  IF OK=YES THEN 1070
  107. 1050  PRINT "Don't have that name."
  108. 1060  RETURN
  109. 1070  GOSUB 2040
  110. 1080  PRINT "Name deleted."
  111. 1090  RETURN
  112. 1100  PRINT
  113. 1110  PRINT "List entire directory by Soundex codes"
  114. 1120  IF SL=0 THEN 1230
  115. 1130  CC=SL
  116. 1140  PRINT CO$(CC)
  117. 1150  PRINT "----"
  118. 1160  CN=NR%(CC)
  119. 1170  PRINT NA$(CN) ,NF$(CN) ,PH$(CN)
  120. 1180  CN=NL%(CN)
  121. 1190  IF CN>0 THEN 1170
  122. 1200  PRINT
  123. 1210  CC=CL%(CC)
  124. 1220  IF CC>0 THEN 1140
  125. 1230  PRINT "End of list"
  126. 1240  RETURN
  127. 1250  L1$=NU$
  128. 1260  FOR C=1 TO LEN(N$)
  129. 1270  C$=MID$(N$,C,1)
  130. 1280  SQ=ASC(C$)-ASC("a")+1
  131. 1290  IF SQ<1 OR SQ>26 THEN 1310
  132. 1300  L1$=L1$+MID$(S$,SQ,1)
  133. 1310  NEXT C
  134. 1320  L2$=LEFT$(L1$,1)
  135. 1330  LC$=L2$
  136. 1340  FOR C=2 TO LEN(L1$)
  137. 1350  C$=MID$(L1$,C,1)
  138. 1360  IF C$=LC$ THEN 1390
  139. 1370  L2$=L2$+C$
  140. 1380  LC$=C$
  141. 1390  NEXT C
  142. 1400  L3$=LEFT$(N$,1)
  143. 1410  FOR C=2 TO LEN(L2$)
  144. 1420  C$=MID$(L2$,C,1)
  145. 1430  IF C$="0" THEN 1450
  146. 1440  L3$=L3$+C$
  147. 1450  NEXT C
  148. 1460  L3$=LEFT$(L3$+"000",4)
  149. 1470  C$=L3$
  150. 1480  RETURN
  151. 1490  OK=NO
  152. 1500  CC=SL
  153. 1510  PC=0
  154. 1520  IF CC=0 THEN RETURN
  155. 1530  IF CO$(CC)<>C$ THEN 1560
  156. 1540  OK=YES
  157. 1550  RETURN
  158. 1560  IF CO$(CC)>C$ THEN RETURN
  159. 1570  PC=CC
  160. 1580  CC=CL%(CC)
  161. 1590  GOTO 1520
  162. 1600  IF AC<>0 THEN 1630
  163. 1610  OK=NO
  164. 1620  RETURN
  165. 1630  OK=YES
  166. 1640  SC=AC
  167. 1650  AC=CL%(AC)
  168. 1660  KC=KC+1
  169. 1670  CO$(SC)=C$
  170. 1680  CL%(SC)=CC
  171. 1690  NR%(SC)=0
  172. 1700  CC=SC
  173. 1710  IF PC<>0 THEN 1740
  174. 1720  SL=CC
  175. 1730  RETURN
  176. 1740  CL%(PC)=CC
  177. 1750  RETURN
  178. 1760  OK=NO
  179. 1770  CN=NR%(CC)
  180. 1780  PN=0
  181. 1790  IF CN=0 THEN RETURN
  182. 1800  IF NA$(CN)+NF$(CN)<>N$+NF$ THEN 1830
  183. 1810  OK=YES
  184. 1820  RETURN
  185. 1830  IF NA$(CN)+NF$(CN)>N$+NF$ THEN RETURN
  186. 1840  PN=CN
  187. 1850  CN=NL%(CN)
  188. 1860  GOTO 1790
  189. 1870  IF AN<>0 THEN 1900
  190. 1880  OK=NO
  191. 1890  RETURN
  192. 1900  OK=YES
  193. 1910  SN=AN
  194. 1920  AN=NL%(AN)
  195. 1930  KN=KN+1
  196. 1940  NA$(SN)=N$
  197. 1950  NF$(SN)=NF$
  198. 1960  PH$(SN)=PH$
  199. 1970  NL%(SN)=CN
  200. 1980  CN=SN
  201. 1990  IF PN<>0 THEN 2020
  202. 2000  NR%(CC)=CN
  203. 2010  RETURN
  204. 2020  NL%(PN)=CN
  205. 2030  RETURN
  206. 2040  IF PN<>0 THEN 2070
  207. 2050  N%(CC)=NL%(CN)
  208. 2060  GOTO 2080
  209. 2070  NL%(PN)=NL%(CN)
  210. 2080  NA$(CN)=NU$
  211. 2090  NF$(CN)=NU$
  212. 2100  PH$(CN)=NU$
  213. 2110  NL%(CN)=AN
  214. 2120  AN=CN
  215. 2130  KN=KN-1
  216. 2140  IF NR%(CC)<>0 THEN RETURN
  217. 2150  IF CC<>SL THEN 2180
  218. 2160  SL=CL%(CC)
  219. 2170  GOTO 2190
  220. 2180  CL%(PC)=CL%(CC)
  221. 2190  CO$(CC)=NU$
  222. 2200  CL%(CC)=AC
  223. 2210  AC=CC
  224. 2220  KC=KC-1
  225. 2230  RETURN
  226. 2240  IF KN>0 THEN 2270
  227. 2250  PRINT "This directory file is empty!"
  228. 2260  RETURN
  229. 2270  PRINT "Save names to disk"
  230. 2280  PRINT "Name for the output file(empty line for menu)"
  231. 2290  FO$=NU$
  232. 2300  LINE INPUT FO$
  233. 2310  IF FO$=NU$ THEN RETURN
  234. 2320  OPEN "O",1,FO$
  235. 2330  CC=SL
  236. 2340  CN=NR%(CC)
  237. 2350  PRINT #1, NA$(CN); ","; NF$(CN); ","; PH$(CN)
  238. 2360  CN=NL%(CN)
  239. 2370  IF CN>0 THEN 2350
  240. 2380  CC=CL%(CC)
  241. 2390  IF CC>0 THEN 2340
  242. 2400  PRINT "Directory saved in ";FO$
  243. 2410  CLOSE 1
  244. 2420  RETURN
  245. 2430  PRINT "Load names from disk"
  246. 2440  PRINT "Name the input file (empty line for menu)"
  247. 2450  FI$=NU$
  248. 2460  LINE INPUT FI$
  249. 2470  IF FI$=NU$ THEN RETURN
  250. 2480  OPEN "I",1,FI$
  251. 2490  PRINT "Reading the file, hang loose Bud!"
  252. 2500  IF EOF (1) THEN 2760
  253. 2510  INPUT #1,N$,NF$,PH$
  254. 2520  IF N$=NU$ THEN 2500
  255. 2530  PRINT N$;",";NF$;",";PH$;
  256. 2540  GOSUB 1250
  257. 2550  GOSUB 1490
  258. 2560  IF OK=YES THEN 2640
  259. 2570  IF AN>0 THEN 2590
  260. 2580  GOTO 2720
  261. 2590  GOSUB 1600
  262. 2600  IF OK=YES THEN 2640
  263. 2610  PRINT "--Cancel: No more soundex folders left, fool!"
  264. 2620  CLOSE 1
  265. 2630  RETURN
  266. 2640  GOSUB 1760
  267. 2650  IF OK=YES THEN 2700
  268. 2660  GOSUB 1870
  269. 2670  IF OK=NO THEN 2720
  270. 2680  PRINT "--OK"
  271. 2690  GOTO 2500
  272. 2700  PRINT "--Cancel: Duplicate name Zippy!"
  273. 2710  GOTO 2500
  274. 2720  PRINT "--Cancel: No more name cards left, Bonzo!"
  275. 2730  CLOSE 1
  276. 2740  RETURN
  277. 2750  PRINT
  278. 2760  PRINT "End of file ";FI$
  279. 2770  CLOSE 1
  280. 2780  RETURN
  281.